Developer CD Series 1994 August: Tool Chest/Dev.CD Aug 94.toast/Tool Chest/Development Platforms/Macintosh Common Lisp Related/User Contributions/mapforms (code walker).sea/mapforms (code walker)/subst.lisp

Text File | 1992-04-21 | 17.8 KB | 392 lines | [TEXT/CCL2]

;;; -*- Mode:LISP; Package:Language-Tools; Syntax:Common-Lisp -*-
;;;>>SHARED-MESSAGE
;;;>
;;;>******************************************************************************************
;;;>    This may only be used as permitted under the license agreement under
;;;>    which it has been distributed, and in no other way.
;;;>******************************************************************************************
;;;>
;;;>
;;; Written April 1983 by David A. Moon for use by the Common Lisp community
;;; based on a design by Alan Bawden

;;; Lambda-binding optimizer

;--- Common Lisp version conversion issues:
;--- Depends on CONDITION-CASE which Common Lisp doesn't have yet (for exceptions)
;--- Is someone really going to force me to use <= rather than  ?  Ugh, bletch.

;;; The entry functions to this module are
;;; LET-SUBST, LET*-SUBST, DEFSUBST, DEFSUBST-WITH-PARENT,
;;; ONCE-ONLY, EXPAND-SUBST-DEFINITION-INTERNAL
;;;
;;; EXPAND-SUBST-DEFINITION-INTERNAL is not exported, it's only called
;;; from SI:EXPAND-SUBST-DEFINITION.

(EXPORT '(LET-SUBST LET*-SUBST DEFSUBST DEFSUBST-WITH-PARENT ONCE-ONLY
      *LET-SUBST-DECIDE-TRACE*))


;;; The idea of LET-SUBST is that
;;;    (LET-SUBST vars vals form)
;;; could return
;;;    `((LAMBDA (,@vars) ,form) ,@vals)
;;; but normally it will analyze the body and the vals and substitute a val
;;; for occurrences of the corresponding var inside the body if at all possible.
;;; The vars had better not have been declared special or the analysis won't work.
;;; The expansion will not always be a LET.  If the body form needs to scope
;;; declarations or BINDs, it should contain an explicit LET or LOCALLY.
(DEFUN LET-SUBST (VARS VALS FORM)
  (COND ((NOT (NULL VARS))
     ;; Do something reasonable if the form cannot be understood
     (CONDITION-CASE (FAILURE)
         ;; First see how the form uses the vars
         (LET ((VARNOTES (LOOP FOR VAR IN VARS COLLECTING (MAKE-VARNOTE :NAME VAR))))
           (ANNOTATE-FORM FORM VARNOTES)
           ;; Then decide which variables are to be substituted
           (LET-SUBST-INTERNAL VARS VALS VARNOTES FORM T))
       (FORM-NOT-UNDERSTOOD
         (FORMAT *ERROR-OUTPUT* "~&LET-SUBST is punting because ~A" FAILURE)
         `((LAMBDA (,@VARS) ,FORM) ,@VALS))))
    (T FORM)))

;;; LET*-SUBST is similar, but uses serial binding
(DEFUN LET*-SUBST (VARS VALS FORM)
  (COND ((NOT (NULL VARS))
     ;; Do something reasonable if the form cannot be understood
     (CONDITION-CASE (FAILURE)
         ;; First see how the form uses the vars
         (LET ((VARNOTES (LOOP FOR VAR IN VARS COLLECTING (MAKE-VARNOTE :NAME VAR))))
           (ANNOTATE-FORM FORM VARNOTES)
           ;; Then decide which variables are to be substituted
           (LET-SUBST-INTERNAL VARS VALS VARNOTES FORM NIL))
       (FORM-NOT-UNDERSTOOD
         (FORMAT *ERROR-OUTPUT* "~&LET*-SUBST is punting because ~A" FAILURE)
         `(LET* ,(MAPCAR #'LIST VARS VALS) ,FORM))))
    (T FORM)))

(DEFUN LET-SUBST-INTERNAL (VARS VALS VARNOTES FORM PARALLEL)
  (LET* (;; Decide which variables are to be substituted
     ;; DECISIONS is a list parallel to VARS and VALS
     ;; Each element of this list is a list (substp notepad freevars)
     ;;  substp is T if the value is to be substituted, NIL if not
     ;;  notepad is the annotation of the value
     ;;  freevars is the list of variables used freely by the value
     (DECISIONS (LET-SUBST-DECIDE VARS VALS VARNOTES VARNOTES PARALLEL))
     ;; Collect the variables that are used free by the forms that
     ;; are getting substituted into the FORM
     (FREE-VARS (LOOP FOR (SUBSTP VALUE-NOTEPAD FREE) IN DECISIONS
              WHEN SUBSTP
                APPEND FREE))
     ;; This special variable accumulates the substitutions to be done
     (SUBSTITUTIONS NIL)
     ;; Collect the bindings for the unsubstituted variables.
     ;; This may involve renaming non-substituted variables that conflict with
     ;; substituted forms that are now being moved inside their scope.
     (LETS (LOOP FOR (SUBSTP) IN DECISIONS
             FOR VAR IN VARS
             FOR VAL IN VALS
             DO (AND (NOT PARALLEL)
                 SUBSTITUTIONS
                 (SETQ VAL (LET-SUBST-COPYFORMS SUBSTITUTIONS VAL)))
             WHEN (NOT SUBSTP)            ;This variable isn't going away
               DO (WHEN (MEMBER VAR FREE-VARS)    ;Does it need to be renamed?
                (PUSH (CONS VAR (SETQ VAR (GENSYM))) SUBSTITUTIONS))
               AND COLLECT (LIST VAR VAL)
             ELSE DO (PUSH (CONS VAR VAL) SUBSTITUTIONS))))
    ;; Generate the substituted FORM
    (WHEN SUBSTITUTIONS
      (SETQ FORM (LET-SUBST-COPYFORMS SUBSTITUTIONS FORM)))
    ;; Three cases: no LET required, no LET variables used in FORM, or a LET is required
    (COND ((NULL LETS) FORM)
      ((LOOP FOR (SUBSTP) IN DECISIONS AND VARNOTE IN VARNOTES
         ALWAYS (OR SUBSTP (ZEROP (VARNOTE-N-USAGES))))
       `(PROGN ,@(MAPCAR #'CADR LETS) ,FORM))
      (T `(,(IF PARALLEL `LET `LET*) ,LETS
        ,FORM)))))

(DEFUN LET-SUBST-COPYFORMS (SUBSTITUTIONS BODY)
  (FLET ((LET-SUBST-COPY
       (FORM KIND IGNORE)
       (DECLARE (SYS:DOWNWARD-FUNCTION))
       (BLOCK LET-SUBST-COPY
         (CASE KIND
           (SYMEVAL
         (LET ((TEM (ASSOC FORM SUBSTITUTIONS)))
           (WHEN TEM
             (RETURN-FROM LET-SUBST-COPY (VALUES (CDR TEM) T)))))    ;Make substitution and don't subst inside it
           ((SET LET)
        (WHEN (ASSOC FORM SUBSTITUTIONS)
          (ERROR "Attempt to set or bind the SUBST parameter ~S." FORM))))
         FORM)))
    (COPYFORMS #'LET-SUBST-COPY BODY)))

;For EXPAND-SUBST-DEFINITION
(DEFVAR *INNOCUOUS-VARNOTE* (MAKE-VARNOTE :NAME '*INNOCUOUS-VARNOTE*
                      :N-USAGES 1))

;A debugging feature
(DEFVAR *LET-SUBST-DECIDE-TRACE* NIL)

;Replace this (in LET-SUBST-DECIDE) with AND to dike out the tracing code
(DEFMACRO LET-SUBST-DECIDE-TRACE-HACK (&REST FORMS)
  (COND ((NULL FORMS) T)
    ((NULL (CDR FORMS)) (CAR FORMS))
    (T (LET ((FORM (CAR FORMS)))
         (AND (LISTP FORM) (EQ (FIRST FORM) 'SI:DISPLACED)
          (SETQ FORM (THIRD FORM)))
         `(COND (,FORM (LET-SUBST-DECIDE-TRACE-HACK . ,(CDR FORMS)))
            (*LET-SUBST-DECIDE-TRACE*
             (FORMAT *TRACE-OUTPUT*
                 "~2&~S returned NIL, hence ~S will not be substituted for ~S.~@
                   ~@{~S=~S~^, ~}~2%"
                 ',(COPY-LIST FORM)    ;to avoid displacement
                 VAL VAR
                 . ,(LOOP FOR ARG IN (CDR FORM)
                      COLLECT `',ARG
                      COLLECT `,ARG))
             NIL))))))

;; Decide which values may be substituted in.
;; This has to be done right to left (by recursion) so that we know
;; whether we will be moving a value past any value to its right, and
;; so that with serial binding the forms to the right of a variable
;; act like part of the body as far as that variable is concerned.
(DEFUN LET-SUBST-DECIDE (VARS VALS VARNOTES RIGHT-VARNOTES PARALLEL &AUX VNP)
  (WHEN RIGHT-VARNOTES
    (LET ((VAR (POP VARS))
      (VAL (POP VALS))
      (VARNOTE (OR (CAR RIGHT-VARNOTES) *INNOCUOUS-VARNOTE*))
      (DECISIONS (LET-SUBST-DECIDE VARS VALS VARNOTES (CDR RIGHT-VARNOTES) PARALLEL)))
      VAR ;not actually used
      ;; Now we have the value form to be substituted, the information
      ;; about where it will go, and the decisions for the values
      ;; to its right.  Analyze the value form.
      (MULTIPLE-VALUE-BIND (NOTEPAD FREE-VARIABLES FREE-BLOCKS FREE-TAGS REPLICABILITY)
      (ANNOTATE-FORM VAL (AND (NOT PARALLEL)
                  (LDIFF VARNOTES RIGHT-VARNOTES)))
    (LET ((DECISION
           (LET-SUBST-DECIDE-TRACE-HACK
            ;; Variable has not been used in an unsubstitutable way
            (SETQ VNP (VARNOTE-NOTEPAD))
            ;; Value does not have a free variable reference captured by body form
            ;(DISJOINT-SETS FREE-VARIABLES (VARNOTE-VARIABLE-ENV))
            ;; The above test is made stronger to allow for the fact that
            ;; an arbitrary side-effect might be influenced by the binding
            ;; of a special variable.  Here we assume that all variables
            ;; in varnote-variable-env might have been declared special,
            ;; had their LOCF taken, or otherwise be "global" in scope.
            (DISJOINT-SETS (NOTEPAD-READ) (VARNOTE-VARIABLE-ENV))
            (DISJOINT-SETS (NOTEPAD-WRITTEN) (VARNOTE-VARIABLE-ENV))
            ;; No captured free block references
            (DISJOINT-SETS FREE-BLOCKS (VARNOTE-BLOCK-ENV))
            ;; No captured free go tag references
            (DISJOINT-SETS FREE-TAGS (VARNOTE-TAG-ENV))
            ;; Either no side-effects and not evaluated so many times as to hurt
            ;; code density, or has side-effects but is evaluated exactly once.
            (IF (NOTEPAD-WRITTEN)
            (AND (= (VARNOTE-N-USAGES) 1)
                 (NOT (NOTEPAD-CONTROL VNP)))
            (<= (VARNOTE-N-USAGES) REPLICABILITY))
            ;; May pass over everything that happens from the beginning of
            ;; the body up to the last place the variable appears.
            (DISJOINT-NOTES VNP NOTEPAD)
            ;; May pass over values to its right
            (LOOP WITH PASSED = (NOTEPAD-SUBSTS VNP)
              FOR (SUBSTP PAD) IN DECISIONS
              FOR VAR IN VARS
              WHEN (OR (NOT SUBSTP)        ;Would pass over form in LET
                   (MEMBER VAR PASSED))    ;Would pass over substituted form
                ALWAYS (DISJOINT-NOTES PAD NOTEPAD)))))
      (CONS (LIST DECISION NOTEPAD FREE-VARIABLES) DECISIONS))))))

;;;; DEFSUBST

#+LISPM (PROGN 'COMPILE        ;Only the Lisp Machine compiler understands substs

;; The predigested form of the subst is stored in the debug-info of the function.
;; During compilation it is also stored in the file-local declarations.
;; In either case this is a list, called a subst-definition, that looks like
;;    (SUBST-DEFINITION lambda-list vars varnotes body)
;;  lambda-list is the original lambda-list
;;  vars is a list of the variables by themselves (cons it once since it's needed later)
;;  varnotes is a list of varnotes for each variable, or of NIL if the variable may always
;;   be substituted, or NIL as the whole list if all the elements are NIL
;;  body is a single form

(DEFPROP SUBST-DEFINITION T SI:DEBUG-INFO)

;--- Temporary while this is being used to clobber LMMAC.  Suppress redefinition warnings.
(SYS:RECORD-SOURCE-FILE-NAME 'DEFSUBST-WITH-PARENT 'ZL:DEFUN T)


;; (DEFSUBST name (args...) body)
;; is the same as DEFUN except that the function will be open-coded
;; body may be preceded by a documentation string and documentation-type declarations.
;; Other declarations are not permitted since they will not be included in
;; the open-coded version.  Declaration of the
;; the args variables is not allowed, since they can be optimized out.  To include
;; declarations in the body, wrap it in a LOCALLY or a LET.
;; After the documentation and declarations, the body may contain multiple forms,
;; which will be wrapped in a PROGN when the function is open-coded.

;(DEFMACRO DEFSUBST (FUNCTION LAMBDA-LIST &BODY BODY)
; defined in BOOT

(DEFUN EXPAND-DEFSUBST (FUNCTION LAMBDA-LIST BODY &AUX (VARS NIL) FORM)
  ;; Only symbols work as names, not general function specs [contrary to the manual]
  (CHECK-TYPE FUNCTION SYMBOL)
  ;; Only &OPTIONAL, &KEY, and &REST work in the lambda list.  Supplied-p doesn't work.
  ;; We may as well do all the rest of the lambda-list syntax checks, even though
  ;; the compiler will do some of them when the function is compiled.
  (LOOP FOR L ON LAMBDA-LIST AS X = (CAR L) WITH OPTIONAL = NIL WITH KEY = NIL DO
    (COND ((EQ X '&OPTIONAL)
       (SETQ OPTIONAL T))
      ((EQ X '&KEY)
       (SETQ KEY T))
      ((EQ X '&REST)
       (AND (OR (NOT (= (LIST-LENGTH L) 2))
            (NOT (SYMBOLP (CADR L))))
        (DEFSUBST-ERROR FUNCTION T "(...~{~S~^ ~}) is illegal use of &REST" L))
       (PUSH (CADR L) VARS))
      ((MEMBER X LAMBDA-LIST-KEYWORDS)
       (DEFSUBST-ERROR FUNCTION T "The keyword ~S is inappropriate in a DEFSUBST" X))
      ((SYMBOLP X)
       (PUSH X VARS))
      ((OR (ATOM X)
           (NOT (OR OPTIONAL KEY))
           (NOT (OR (SYMBOLP (CAR X))
            (AND KEY (CONSP (CAR X)) (SYMBOLP (CAAR X)) (SYMBOLP (CADAR X))))))
       (DEFSUBST-ERROR FUNCTION T "~S appears where a variable is expected" X))
      ((NULL (CDR X))
       (PUSH (IF (SYMBOLP (CAR X)) (CAR X) (CADAR X)) VARS))
      ((CDDR X)
       (DEFSUBST-ERROR FUNCTION T "Supplied-p variables ~S do not work in DEFSUBST." X))
      (T        ;Optional or keyword argument with initialization
       (MULTIPLE-VALUE-BIND (NIL FREE) (ANNOTATE-FORM (CADR X))
         (IF (INTERSECTION FREE VARS)
         (DEFSUBST-ERROR FUNCTION T
                 "The binding ~S depends on sequential binding, which does~@
                  not currently work in DEFSUBST."
                 X)))
       (PUSH (IF (SYMBOLP (CAR X)) (CAR X) (CADAR X)) VARS))))
  (SETQ VARS (NREVERSE VARS))
  (IF (EQUAL VARS LAMBDA-LIST)            ;Save storage later
      (SETQ VARS LAMBDA-LIST))
  (AND (MEMBER '&KEY LAMBDA-LIST :TEST #'EQ) (MEMBER '&REST LAMBDA-LIST :TEST #'EQ)
       (DEFSUBST-ERROR FUNCTION T "&KEY and &REST cannot be used together in a DEFSUBST"))
  ;; Parse off the declarations, converting BODY into FORM
  (LOOP WITH BOD = BODY
    DO (COND ((AND (STRINGP (CAR BOD)) (CDR BOD))    ;Documentation string
          (SETQ BOD (CDR BOD)))
         ((AND (LISTP (CAR BOD)) (EQ (CAAR BOD) 'DECLARE))
          (DOLIST (DCL (CDAR BOD))
            (UNLESS (AND (LISTP DCL)    ;Something like (DECLARE (ARGLIST ...))
                 (SYMBOLP (CAR DCL))
                 (GET (CAR DCL) 'SI:DEBUG-INFO))
              (DEFSUBST-ERROR FUNCTION NIL
                      "The declaration ~S will not work, because it~@
                       will not be included when the function is ~
                       substituted in-line."
                      DCL)))
          (SETQ BOD (CDR BOD)))
         (T (SETQ FORM (IF (= (LIST-LENGTH BOD) 1) (FIRST BOD) (CONS 'PROGN BOD)))
            (RETURN))))
  ;; Analyze the body, similarly to first part of LET-SUBST, and produce a subst-definition
  (LET ((VARNOTES (LOOP FOR VAR IN VARS COLLECT (MAKE-VARNOTE :NAME VAR))))
    (ANNOTATE-FORM FORM VARNOTES)
    ;; Smash the varnote for any variable that has no constraints on substitution
    ;; since this is actually the usual case, e.g. for most defstruct accessors
    (LOOP FOR L ON VARNOTES AS VARNOTE = (CAR L) WITH VNP DO
      (AND (SETQ VNP (VARNOTE-NOTEPAD))    ;Variable isn't used in some horrible way
       (NULL (VARNOTE-VARIABLE-ENV))    ; and isn't used inside a lexical contour
       (NULL (VARNOTE-BLOCK-ENV))        ; of any of the three kinds
       (NULL (VARNOTE-TAG-ENV))
       (= (VARNOTE-N-USAGES) 1)        ; and is only used once
       (NOT (NOTEPAD-CONTROL VNP))        ; and isn't inside control structure
       (NULL (NOTEPAD-READ VNP))        ; and isn't used after side-effects
       (NULL (NOTEPAD-WRITTEN VNP))
       (LOOP FOR (VAR) IN (CDR L)        ; and isn't used out of order with
         NEVER (MEMBER VAR (NOTEPAD-SUBSTS VNP)))    ; the variables to its right
       (SETF (CAR L) NIL)))
    (AND (LOOP FOR X IN VARNOTES ALWAYS (NULL X))
     (SETQ VARNOTES NIL))            ;All varnotes smashed
    ;; Build the structure needed later to open-code this function
    (LET ((SUBST-DEFINITION (LIST 'SYS:SUBST-DEFINITION LAMBDA-LIST VARS VARNOTES FORM)))
      ;; If this is for a compilation, check that it wasn't previously assumed a function.
;      (COMPILER:MAYBE-WARN-ABOUT-MACRO-DEFINITION FUNCTION SUBST-DEFINITION)
      ;; Tell the world about it
      `(PROGN 'COMPILE
          (EVAL-WHEN (COMPILE)
        (COMPILER:FILE-DECLARE ',FUNCTION 'ZL:DEF ',SUBST-DEFINITION))
          (DEFUN ,FUNCTION ,LAMBDA-LIST
        (DECLARE ,SUBST-DEFINITION)
        . ,BODY)))))

;This is for defstruct (or anything else that writes substs automatically
;as part of the expansion of some other form).
;PARENT is a list of the parent definition name and its definition type.
;Also accepted is a symbol, which is what it used to be (for old compiled defstructs).
(DEFMACRO DEFSUBST-WITH-PARENT (FUNCTION PARENT LAMBDA-LIST &BODY BODY)
  (IF (NOT (LISTP PARENT)) (SETQ PARENT (LIST PARENT)))
  `(DEFSUBST ,FUNCTION ,LAMBDA-LIST
     (DECLARE (FUNCTION-PARENT ,@PARENT))
     . ,BODY))

;Report errors in the DEFSUBST macro in a nice way, hooked up with the compiler
(DEFUN DEFSUBST-ERROR (FUNCTION FATAL FORMAT-STRING &REST FORMAT-ARGS)
  (LET ((COMPILER:DEFAULT-WARNING-FUNCTION FUNCTION)
    (COMPILER:DEFAULT-WARNING-DEFINITION-TYPE 'ZL:DEFUN))
    (APPLY #'COMPILER:WARN (AND FATAL '(:ERROR T)) FORMAT-STRING FORMAT-ARGS)))
(DEFPROP DEFSUBST-ERROR T :ERROR-REPORTER)

;; Expand a call to a SUBST function.
;; SUBST is the subst-definition to use; FORM is the whole form.
;; This is called by SI:EXPAND-SUBST-DEFINITION as an interface into the language tools.
(DEFUN EXPAND-SUBST-DEFINITION-INTERNAL (VARS VALS VARNOTES BODY)
  ;; Plug in values in one of two different ways depending on whether it
  ;; is necessary to do code analysis of the values.  In the usual case
  ;; all the varnotes would be innocuous and no analysis is required.
  (IF VARNOTES
      ;; Do a LET-SUBST, except that the body has already been analyzed
      (LET-SUBST-INTERNAL VARS VALS VARNOTES BODY T)
      ;; Plug them all in.  Don't use SUBLIS to avoid name clashes with non-variables.
      (LET-SUBST-COPYFORMS (PAIRLIS VARS VALS) BODY)))

);#+LISPM

;;;; ONCE-ONLY

;See page 222 of the Chine Nual.  Admittedly the documentation there is incomprehensible.

;;; Create code that is body, possibly with a lambda wrapped around it to make
;;; sure that the forms assigned to the listed variables only get evaluated once.
#-EXPLORER
(DEFMACRO ONCE-ONLY (VARIABLE-LIST &BODY BODY)
  ;; Check the syntax of the macro-call that invoked us
  (DOLIST (VARIABLE VARIABLE-LIST)
    (OR (VARIABLEP VARIABLE)
    (ERROR "~S is not a variable" VARIABLE)))
  ;; Generate code that evaluates the body with each variable bound to a gensym
  ;; then uses LET-SUBST to remove the gensyms where possible.  When a gensym cannot
  ;; be removed, the form returned by the body is wrapped in a binding of the gensym.
  ;; The gensyms need to be distinct from any expression that might get incorporated
  ;; into the result of the body, so we have to make new gensyms on every invocation.
  ;; If we were willing to make two copies of the body, we could have a special case
  ;; for when the values of all the variables are atoms (variables or constants)
  ;; in which case no let-subst and no gensyms are required.  But this doesn't
  ;; seem worthwhile.
  `(LET ((ONCE-ONLY-TEMPS (LIST . ,(LOOP FOR L ON VARIABLE-LIST COLLECT `(GENSYM)))))
     (LET-SUBST ONCE-ONLY-TEMPS
        (LIST . ,VARIABLE-LIST)
        (LET ,(LOOP FOR VAR IN VARIABLE-LIST
                COLLECT `(,VAR (POP ONCE-ONLY-TEMPS)))
          . ,BODY))))

;;; Utility for macroexpanding a whole form...

#-EXPLORER
(DEFUN MACROEXPAND-ALL (FORM)
  (COPYFORMS #'(LAMBDA (X &REST IGNORE) X) FORM :EXPAND-ALL-MACROS T))